;;;-*-SCHEME-*-

;;;;  Top level variable so debugger is always available (even if loaded
;;;  during error)

(eval 

'(define debugger-package
  (make-environment


(define-export exit system-global-environment nil)


;;;Read-execute-print loop for a set of commands associated with functions

(define (letter-commands commands prompt)

  (define (inner-loop val)
    (if (eq? val *noprint*) nil
	(print val))
    (newline)
    (let ((input (readch prompt)))
      (let ((func (or (assq input commands)
		      (assq (char (- (ascii input) 32.)) commands))))
	(if (null? func)
	    (inner-loop *noprint*)
	    (inner-loop ((cdr func)))))))

  (define (driver-loop)
    (catch exit
	   (let ((abort-message
		  (catch again
			 (fluid-let ((abort-to-previous-driver
				      abort-to-nearest-driver)
				     (return-to-caller-of-driver exit)
				     (abort-to-nearest-driver again))
				    (inner-loop *noprint*)))))
	     (display abort-message " Returning to lazy" "loop.")
	     (driver-loop))))
  (driver-loop))

;;;; Environment manipulation package

(define env-package
  (make-environment
   
(define env nil)
(define current-frame nil)
   
;;; Lexpr since it can take one or no arguments
   
(define-export (where . possible-env) system-global-environment
  (loop (if (null? possible-env)
	    (the-read-eval-print-environment)
	    (car possible-env))))

(define (loop environment)
  (newline)
  (set! env environment)
  (set! current-frame environment)
  (letter-commands env-commands "Where--> "))

(define (enter-environment env)
  (read-eval-print env
		   "You are now in the desired environment"
		   "Eval-in-env--> "))


(define (show)
  (show-frame current-frame))

(define (show-all)
  (define (s1 env)
    (if (eq? system-global-environment env) *noprint*
	(sequence
	 (show-frame env)
	 (s1 (frame-parent env)))))
  (s1 env))

(define (show-frame frame)
  (if (eq? system-global-environment frame)
      (display "This frame is the global environment")
      (print (frame-bindings frame)))
  (newline))


(define (parent)
  (if (eq? system-global-environment parent)
      (display
       "The current frame is the global environment, it has no parent")
      (sequence
       (set! current-frame (frame-parent current-frame))
       (show))))

(define (son)
  (define (son-1 prev next)
    (if (eq? next current-frame)
	(set! current-frame prev)
	(son-1 next (frame-parent next))))
  (if (eq? current-frame env)
      (display "This frame has no offspring")
      (son-1 env (frame-parent env)))
  (show))

(define (enter) (enter-environment current-frame))

(define (help)
  (display
   "
   E    Create a read-eval-print loop in the current environment
   S    Find the son of the current environment in the current chain
   P    Find the parent frame of the current one
   H    Display the bindings in the current frame
   A    Display the bindings of all the frames in the current chain
   Q    Exit
   ?    Help, print this cruft"))


(define (exit)
  (return-to-caller-of-driver *noprint*))

(define env-commands
  (list `(E ,@enter)
	`(S ,@son)
	`(P ,@parent)
	`(H ,@show)
	`(A ,@show-all)
	`(Q ,@exit)
	`(? ,@help)))

)) ; end ENV-PACKAGE.

;;;;History part of the debugger

(define history-package
  (make-environment

;;; "State" variables

(define history nil)
(define caller nil)
(define error-info nil)


(define spine-levels 0)
(define rib-levels 0)

(define current-height 0)
(define current-width 0)

(define current-reductions nil)
(define current-branches nil)
(define current-reduction nil)
(define $ nil)

(define toggle nil)
(define *exit* '(*exit*))
(define *change-mode* '(*change-mode*))

;;; Manipulators:


(define (rib-reductions rib) (car rib))

(define (rib-subexpressions rib) (cadr rib))


(define (branch-expression branch) (car branch))

(define (branch-value branch) (cadr branch))


(define (reduction-procedure reduction)
  (frame-procedure (cadr reduction)))

(define (reduction-arguments reduction)
  (frame-arguments (cadr reduction)))

(define (reduction-environment reduction)
  (cadr reduction))

(define (reduction-expression reduction)
  (car reduction))

   
;;;; Initialization and loops for both modes

(define-export (debug . flag) system-global-environment
  (set! history (the-saved-history))
  (set! caller return-to-caller-of-driver)
  (if history
      (sequence
       (set! error-info
	     (let ((original (car the-read-eval-print-messages)))
	       (cons "Message:"
		     (if (symbol? original)
			 (list original)
			 original))))
       (set! spine-levels (-1+ (length history)))
       (move 0 0 "There is no history saved at all!" nil)
       (if (memq (reduction-procedure current-reduction)
		 (list error bkpt))
	   (sequence
	    (set!-car current-reductions (cadr current-reductions))
	    (set!-cdr current-reductions (cddr current-reductions))
	    (set!-car (cdar history) '(foo))
	    (move 0 0 "There is no history saved at all!" nil)))
       (if (and flag (car flag)) (reduction) (all-history))
       (mode))
      (display "There is no history saved at all!")))


(define (lazy-mode)
  (let ((val (letter-commands hist-commands
			      "Lazy-debug--> ")))
    (if (eq? val *exit*)
	*noprint*
	(sequence (set! mode normal-mode)
		  (normal-mode)))))

   
(define (normal-mode)
  (fluid-let ((exit return-to-caller-of-driver))
    (catch toggle-mode
	   (sequence
	    (set! toggle toggle-mode)
	    (read-eval-print history-package
			     "You are in debugger command mode"
			     "Debugger-command--> "))))
  (set! mode lazy-mode)
  (lazy-mode))

     
;;;; Commands

;;; Environments:
   
(define (debug-where)					;command W
  (where
   (reduction-environment current-reduction)))

(define (enter)						;command E
  ((access enter-environment env-package)
   (reduction-environment current-reduction)))

(define (eval-in-current-environment)			;command V
  (newline)
  (eval (read "Eval--> ")
	(reduction-environment current-reduction)))

(define (procedure)
  (reduction-procedure current-reduction))

(define (environment)
  (reduction-environment current-reduction))

   
;;;Proceeding:
   
(define (return-lazy)					;command R
  (newline)
  (let ((inp (read "Exp to proceed with: -> ")))
    (newline)
    (if (read "Confirm: [T or NIL] -> ")
	(return (if (eq? inp '$) $ inp))
	*noprint*)))


;;; FIX DYNAMIC THROW TO FORCE VALUE OF DELAYS WHICH GO THROUGH IT.

(define (return exp)
  ;; EVALUATION SHOULD HAPPEN AFTER THROW!
  (let ((val (eval exp (reduction-environment current-reduction)))
	(appropriate-caller (find-caller current-height caller)))
    (merge-history current-height)
    (appropriate-caller val)))

(define find-caller (get-lisp-procedure 'find-caller))

;;;Displaying:

(define (all-history)					;command H
  (display-history history 0))

(define (display-history left level)
  (cond ((null? left) *noprint*)
	((eq? left 'wrap-around)
	 (display "Wrap around in history!")
	 (newline))
	(else
	 (display-rib (rib-reductions (car left)) 0 level)
	 (display-history (cdr left) (1+ level)))))


(define (all-reductions)				;command A
  (display-rib current-reductions 0 current-height))

(define (display-rib rib wi he)
  (cond ((null? rib) *noprint*)
	((eq? rib 'wrap-around)
	 (display "Wrap around in the reductions at this level!")
	 (newline))
	((and (= he spine-levels)
	      (eq? (reduction-procedure (car rib))
		   eval))
	 *noprint*)
	(else
	 (display-reduction (car rib) he wi)
	 (display-rib (cdr rib) (1+ wi) he))))

   
(define (reduction)					;command S
  (newline)
  (display-reduction current-reduction current-height current-width))
   
(define (display-reduction reduction he wi)
  (display "Subproblem level:" he " Reduction number:" wi)
  (display "Expression" (unsyntax (reduction-expression reduction)))
  (display "Within procedure" (reduction-procedure reduction)
	   "applied to" (reduction-arguments reduction))
  (newline))


(define (subexpressions)                     ;command X
  (display-branches current-branches))

(define (display-branches branches)
  (cond ((null? branches) *noprint*)
	((eq? branches 'wrap-around)
	 (display "Wrap around in the subexpressions at this level!")
	 (newline))
	(else
	 (display "Subexpression:"
		  (unsyntax (branch-expression (car branches)))
		  " value:" (branch-value (car branches)))
	 (newline)
	 (display-branches (cdr branches)))))



(define (print-procedure)				;command P
  (pp (reduction-procedure current-reduction)))



   ;;;Motion:

(define (previous-subproblem)				;command D
  (move (1+ current-height) 0
	"You are already at the first subproblem level" t))

(define (next-subproblem)				;command U
  (move (-1+ current-height) 0
	"You are already at the last subproblem level" t))

(define (next-reduction)				;command F
  (h-move (-1+ current-width)
	  "You are already at the last reduction at this level" t))

(define (previous-reduction)				;command B
  (h-move (1+ current-width)
	  "You are already at the first reduction at this level" t))

(define (go-lazy)					;command G
  (newline)
  (let ((rb (read "Reduction number --> "))
	(sp (read "Subproblem level --> ")))
    (if (and (number? sp) (number? rb))
	(move sp rb "That reduction doesn't exist" t)
	(go-lazy))))

(define (go level reduction)
  (move level reduction "That reduction doesn't exist" t))

(define (move he wi error-message display?)
  (if (or (< he 0) (> he spine-levels))
      (display error-message)
      (let ((temp-rib (nth he history)))
	(set! current-reductions (rib-reductions temp-rib))
	;; Current branch doesn't have value
	(set! current-branches
	      (cdr (rib-subexpressions temp-rib)))
	(set! current-height he)
	(h-move wi error-message display?)
	(if (= wi current-width) *noprint*
	    (h-move 0 "Bad history" nil)))))

(define (h-move wi error-message display?)
  (let ((temp-width (-1+ (length current-reductions))))
    (if (or (> wi temp-width) (< wi 0))
	(display error-message)
	(sequence
	 (set! current-width wi)
	 (set! current-reduction
	       (nth current-width current-reductions))
	 (set! $ (unsyntax (reduction-expression current-reduction)))
	 (if display? (reduction) *noprint*)))))
   
;;; Debugger system commands

(define (info)						;command I
  (newline)
  (apply display error-info)
  (newline))

(define (help)						;command ?
  (display help-message))

(define (change-mode)					;command M
  (return-to-caller-of-driver *change-mode*))

(define (exit-lazy)					;command Q
  (return-to-caller-of-driver *exit*))


(define hist-commands
  (list (cons '? help)
	(cons 'H all-history)
	(cons 'A all-reductions)
	(cons 'Q exit-lazy)
	(cons 'U next-subproblem)
	(cons 'D previous-subproblem)
	(cons 'F next-reduction)
	(cons 'B previous-reduction)
	(cons 'X subexpressions)
	(cons 'I info)
	(cons 'V eval-in-current-environment)
	(cons 'E enter)
	(cons 'S reduction)
	(cons 'W debug-where)
	(cons 'R return-lazy)
	(cons 'M change-mode)
	(cons 'G go-lazy)
	(cons 'P print-procedure)))


(define help-message "
U     Move up one subproblem level to <Next-subproblem>
D     Move down one subproblem level to <Previous-subproblem>
F     Move forward to <Next-reduction> on the same subproblem level
B     Move backwards to <Previous-reduction> on the same subproblem level
G     <Go> to subproblem and reduction desired

S     Show the current <Reduction> in short form
X     Show the <Subexpressions> of the last reduction at this level
P     <Print-procedure>, pretty-prints current procedure
A     <All-reductions>, display all the reductions at this level
H     <All-history>, display all the available history

V     <Eval-in-current-environment> an expression
E     <Enter>, enter a read-eval-print loop in the current environment
R     <Return>, evaluate an expression and proceed with it
W     <Debug-where>, display and manipulate the current environment

I     <Info>, repeat error message
M     <Toggle>, change debug mode
Q     <Exit> the debugger
?     <Help> prints this garbage")

(define mode lazy-mode)

)) ; end HISTORY-PACKAGE.
)) ; end DEBUGGER-PACKAGE.


scheme-system-package)